home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / unix / volume10 / ifp / part03 < prev    next >
Encoding:
Text File  |  1987-07-05  |  49.9 KB  |  2,093 lines
  1. Path: uunet!rs
  2. From: rs@uunet.UU.NET (Rich Salz)
  3. Newsgroups: comp.sources.unix
  4. Subject: v10i036: Interpreted Functional Programming lanuage, Part 03/07
  5. Message-ID: <573@uunet.UU.NET>
  6. Date: 7 Jul 87 04:32:09 GMT
  7. Organization: UUNET Communications Services, Arlington, VA
  8. Lines: 2082
  9. Approved: rs@uunet.uu.net
  10.  
  11. Mod.sources: Volume 10, Number 36
  12. Submitted by: robison@b.cs.uiuc.edu (Arch Robison)
  13. Archive-name: ifp/Part03
  14.  
  15. #! /bin/sh
  16. # This is a shell archive, meaning:
  17. # 1. Remove everything above the #! /bin/sh line.
  18. # 2. Save the resulting text in a file.
  19. # 3. Execute the file with /bin/sh.
  20. # The following files will be created:
  21. #    interp/F_arith.c
  22. #    interp/F_misc.c
  23. #    interp/F_pred.c
  24. #    interp/F_seq.c
  25. #    interp/F_ss.c
  26. #    interp/F_string.c
  27. #    interp/F_subseq.c
  28. export PATH; PATH=/bin:$PATH
  29. mkdir interp
  30. if test -f 'interp/F_arith.c'
  31. then
  32.     echo shar: over-writing existing file "'interp/F_arith.c'"
  33. fi
  34. cat << \SHAR_EOF > 'interp/F_arith.c'
  35.  
  36. /****** F_arith.c *****************************************************/
  37. /**                                                                  **/
  38. /**                    University of Illinois                        **/
  39. /**                                                                  **/
  40. /**                Department of Computer Science                    **/
  41. /**                                                                  **/
  42. /**   Tool: IFP                         Version: 0.5                 **/
  43. /**                                                                  **/
  44. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  45. /**                                                                  **/
  46. /**   Revised by: Arch D. Robison       Date:  June 4, 1986          **/
  47. /**                                                                  **/
  48. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  49. /**                            Prof. W. J. Kubitz                    **/
  50. /**                                                                  **/
  51. /**                                                                  **/
  52. /**------------------------------------------------------------------**/
  53. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  54. /**                       All Rights Reserved.                       **/
  55. /**********************************************************************/
  56.  
  57. #include <stdio.h>
  58. #include <math.h>
  59. #include <errno.h>
  60. #include "struct.h"
  61. #include "node.h"
  62.  
  63. #if OPSYS!=CTSS
  64. extern int errno;      /* exists somewhere in UNIX */
  65. #endif
  66.  
  67. /* NOTE - function Dyadic assumes integers are in two's complement form! */
  68.  
  69. private F_Minus (), F_AddN (), Monadic (), Dyadic (), F_Sum ();
  70.  
  71. private OpDef OpArith [] = {
  72. #if OPSYS!=CTSS
  73.    {"ln",       0,      Monadic},
  74.    {"exp",      1,      Monadic},
  75.    {"sqrt",     2,      Monadic},
  76.    {"sin",      3,      Monadic},
  77.    {"cos",      4,      Monadic},
  78.    {"tan",      5,      Monadic},
  79.    {"arcsin",   6,      Monadic},
  80.    {"arccos",   7,      Monadic},
  81.    {"arctan",   8,      Monadic},
  82. #endif
  83.    {"minus",    -1,     F_Minus},
  84.    {"add1",     1,      F_AddN},
  85.    {"sub1",     -1,     F_AddN},
  86.    {"+",        0,      Dyadic},
  87.    {"-",        1,      Dyadic},
  88.    {"*",        2,      Dyadic},
  89.    {"%",        3,      Dyadic},
  90. #if OPSYS!=CTSS
  91.    {"mod",      4,      Dyadic},
  92.    {"div",      5,      Dyadic},
  93. #endif
  94.    {"min",      6,      Dyadic},
  95.    {"max",      7,      Dyadic},
  96. #if OPSYS!=CTSS
  97.    {"power",    8,      Dyadic},
  98. #endif
  99.    {"sum",      -1,     F_Sum}
  100. };
  101.  
  102.  
  103. /*
  104.  * Monadic
  105.  *
  106.  * Evaluate a monadic function
  107.  *
  108.  * Input
  109.  *      InOut = argument to apply function
  110.  *      Op = operation - see array F_Name in code for values
  111.  *
  112.  * Output
  113.  *      InOut = result of applying function
  114.  */
  115. private Monadic (InOut,Op)
  116.    ObjectPtr InOut;
  117.    int Op;
  118.    {
  119.       double X,Z;
  120.       register int E;
  121.  
  122.       if (GetDouble (InOut,&X)) FunError ("not numeric",InOut);
  123.       else {
  124.      E = 0;
  125.      switch (Op) {
  126. #if OPSYS!=CTSS
  127.         case 0:                     /* base e log */
  128.            if (X <= 0) E = EDOM;
  129.            else Z = log (X);
  130.            break;
  131.         case 1:                     /* base e power */
  132.            if (X >= LNMAXFLOAT) E = ERANGE;
  133.            else Z = exp (X);
  134.            break;
  135.         case 2:                     /* square root */
  136.            if (X < 0) E = EDOM;
  137.            else Z = sqrt (X);
  138.            break;
  139.         case 3:                     /* sin */
  140.            Z = sin (X);
  141.            break;
  142.         case 4:                     /* cos */
  143.            Z = cos (X);
  144.            break;
  145.         case 5:                     /* tan */
  146.            Z = tan (X);
  147.            break;
  148.         case 6:                     /* arcsin */
  149.            Z = asin (X);
  150.            E = errno;
  151.            break;
  152.         case 7:                     /* arccos */
  153.            Z = acos (X);
  154.            E = errno;
  155.            break;
  156.         case 8:                     /* arctan */
  157.            Z = atan (X);
  158.            E = errno;
  159.            break;
  160. #endif /* OPSYS!=CTSS */
  161.         case 9:                     /* minus */
  162.            Z = -X;
  163.            E = 0;
  164.            break;
  165.      }
  166.      switch (E) {
  167. #if OPSYS!=CTSS
  168.         case EDOM:
  169.            FunError ("domain error",InOut);
  170.            break;
  171.         case ERANGE:
  172.            FunError ("range error",InOut);
  173.            break;
  174. #endif
  175.         default:
  176.            InOut->Tag = FLOAT;
  177.            InOut->Float = Z;
  178.            break;
  179.      }
  180.       }
  181.    }
  182.  
  183.  
  184. private F_Minus (InOut)
  185.    register ObjectPtr InOut;
  186.    {
  187.       if (InOut->Tag == INT && InOut->Int != FPMaxInt+1)
  188.      InOut->Int = - InOut->Int;
  189.       else Monadic (InOut,9);
  190.    }
  191.  
  192.  
  193. /*
  194.  * F_Sum
  195.  */
  196. private F_Sum (InOut)
  197.    ObjectPtr InOut;
  198.    {
  199.       Object S;
  200.       register ListPtr P;
  201.  
  202.       switch (InOut->Tag) {
  203.      default:
  204.         FunError (ArgNotSeq,InOut);
  205.         return;
  206.      case LIST:
  207.         S.Tag = INT;
  208.         S.Int = 0;
  209.         for (P=InOut->List; P!=NULL; P=P->Next) {
  210.            if (P->Val.Tag != INT && P->Val.Tag != FLOAT) {
  211.           FunError ("non-numeric sequence",InOut); 
  212.           return;
  213.            }
  214.            if (S.Tag == INT) {
  215.           if (P->Val.Tag == INT) {
  216.  
  217.              /* Both arguments are integers. See if we can avoid    */
  218.              /* floating arithmetic.                                */
  219.  
  220.              FPint Zi = S.Int + P->Val.Int;
  221.              if ((S.Int ^ P->Val.Int) < 0 || (S.Int^Zi)) 
  222.              /* arithmetic overflow occured - float result */;
  223.              else {
  224.             S.Int = Zi; 
  225.             continue;
  226.              }
  227.           }
  228.           S.Float = S.Int; 
  229.           S.Tag = FLOAT;
  230.            }
  231.            S.Float += P->Val.Tag==INT ? P->Val.Int : P->Val.Float;
  232.         }
  233.         break;
  234.       }
  235.       RepObject (InOut,&S);
  236.    }
  237.  
  238. /*
  239.  * Dyadic
  240.  *
  241.  * Evaluate a dyadic function
  242.  *
  243.  * Input
  244.  *      InOut = argument to apply function
  245.  *      Op = operation - see case statement in code for possibilities
  246.  *
  247.  * Output
  248.  *      InOut = result of applying function
  249.  *
  250.  * The author sold his anti-GOTO morals for speed.
  251.  */
  252. private Dyadic (InOut,Op)
  253.    register ObjectPtr InOut;
  254.    register int Op;
  255.    {
  256.       double X,Y,Z;
  257.       register FPint Xi,Yi,Zi;
  258.       register ListPtr P,Q;
  259.       static char *DivZero = "division by zero";
  260.  
  261.       if (InOut->Tag != LIST ||
  262.       NULL == (P=InOut->List) ||
  263.       NULL == (Q=P->Next) ||
  264.       Q->Next != NULL ||
  265.       NotNumPair (P->Val.Tag,Q->Val.Tag)) {
  266.  
  267.      FunError ("not a numeric pair",InOut);
  268.      return;
  269.       }
  270.  
  271.       if (IntPair (P->Val.Tag,Q->Val.Tag)) {
  272.  
  273.      /* Both arguments are integers. See if we can avoid floating point */
  274.      /* arithmetic.                                                     */
  275.  
  276.      Xi = P->Val.Int;
  277.      Yi = Q->Val.Int;
  278.  
  279.      switch (Op) {
  280.  
  281.         case 0:
  282.            /* assume two's complement arithmetic */
  283.            Zi = Xi+Yi;
  284.            if (((Xi ^ Yi) | ~(Xi ^ Zi)) < 0) goto RetInt;
  285.            break;
  286.            /* else arithmetic overflow occured */
  287.  
  288.         case 1:
  289.            /* assume two's complement arithmetic */
  290.            Zi = Xi - Yi;
  291.            if (((Xi ^ Yi) & (Xi ^ Zi)) >= 0) goto RetInt;
  292.            /* else arithmetic overflow occured */
  293.            break;
  294.  
  295.         case 2:
  296.            Zi = Xi * Yi;
  297.            if (Yi==0 || Zi/Yi == Xi) goto RetInt;
  298.            /* else arithmetic overflow occured */
  299.            break;
  300.  
  301.      /* case 3: division  result always FLOAT */
  302.  
  303. #if OPSYS!=CTSS
  304.         case 4:                     /* mod */
  305.            if (Xi >= 0 && Yi > 0) {
  306.           Zi = Xi % Yi;
  307.           goto RetInt;
  308.            }
  309.            break;
  310.  
  311.         case 5:                     /* div */
  312.            if (Xi >= 0 && Yi > 0) {
  313.           Zi = Xi / Yi;
  314.           goto RetInt;
  315.            }
  316.            break;
  317. #endif /* OPSYS!=CTSS */
  318.  
  319.         case 6:
  320.            Zi = Xi > Yi ? Yi : Xi;
  321.            goto RetInt;
  322.  
  323.         case 7:
  324.            Zi = Xi < Yi ? Yi : Xi;
  325.            goto RetInt;
  326.  
  327.      /* case 8: power result always FLOAT */
  328.      }
  329.       }
  330.  
  331.       X = P->Val.Tag==INT ? P->Val.Int : P->Val.Float;
  332.       Y = Q->Val.Tag==INT ? Q->Val.Int : Q->Val.Float;
  333.  
  334.       switch (Op) {
  335.      case 0: Z = X + Y; break;
  336.      case 1: Z = X - Y; break;
  337.      case 2: Z = X * Y; break;
  338.      case 3: 
  339.         if (Y==0.0) {
  340.            FunError (DivZero,InOut);
  341.            return;
  342.         }
  343.         Z = X / Y; 
  344.         break;
  345. #if OPSYS!=CTSS
  346.      case 4:
  347.         Z = Y==0.0 ? 0.0 : X - floor (X / Y) * Y;   /* mod */
  348.         break;
  349.      case 5:
  350.         if (Y==0.0) {                               /* div */
  351.            FunError (DivZero,InOut);
  352.            return;
  353.         }
  354.         Z = floor (X / Y);
  355.         break;
  356. #endif
  357.      case 6: Z = X > Y ? Y:X; break;
  358.      case 7: Z = X > Y ? X:Y; break;
  359. #if OPSYS!=CTSS
  360.      case 8: Z = pow (X,Y);   break;
  361. #endif
  362.       }
  363.       InOut->Tag = FLOAT;
  364.       InOut->Float = Z;
  365.  
  366.    Return:
  367.       DelLPtr (P);
  368.       return;
  369.  
  370.    RetInt: 
  371.       InOut->Tag = INT;
  372.       InOut->Int = Zi;
  373.       goto Return;
  374.    }
  375.  
  376.  
  377. /*
  378.  * F_Add1
  379.  */
  380. private F_AddN (InOut,N)
  381.    register ObjectPtr InOut;
  382.    int N;
  383.    {
  384.       register FPint K;
  385.  
  386.       switch (InOut->Tag) {
  387.      case INT:
  388.         K = InOut->Int + N;
  389.         if (N >= 0 ? InOut->Int <= K : InOut->Int >  K) {
  390.            InOut->Int = K;
  391.            return;
  392.         }
  393.         /* else integer overflow - convert and drop down */
  394.         InOut->Float = ((FPfloat) InOut->Int);
  395.         InOut->Tag = FLOAT;
  396.      case FLOAT:
  397.         InOut->Float = InOut->Float + N;
  398.         break;
  399.      default:
  400.         FunError ("not a number",InOut);
  401.         break;
  402.       }
  403.    }
  404.  
  405. void D_arith ()
  406.    {
  407.       GroupDef (OpArith,OpCount (OpArith), ArithNode);
  408.    }
  409.  
  410. /************************** end of F_arith.c **************************/
  411.  
  412. SHAR_EOF
  413. if test -f 'interp/F_misc.c'
  414. then
  415.     echo shar: over-writing existing file "'interp/F_misc.c'"
  416. fi
  417. cat << \SHAR_EOF > 'interp/F_misc.c'
  418.  
  419. /****** F_misc.c ******************************************************/
  420. /**                                                                  **/
  421. /**                    University of Illinois                        **/
  422. /**                                                                  **/
  423. /**                Department of Computer Science                    **/
  424. /**                                                                  **/
  425. /**   Tool: IFP                         Version: 0.5                 **/
  426. /**                                                                  **/
  427. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  428. /**                                                                  **/
  429. /**   Revised by: Arch D. Robison       Date:  Nov 24, 1985          **/
  430. /**                                                                  **/
  431. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  432. /**                            Prof. W. J. Kubitz                    **/
  433. /**                                                                  **/
  434. /**                                                                  **/
  435. /**------------------------------------------------------------------**/
  436. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  437. /**                       All Rights Reserved.                       **/
  438. /**********************************************************************/
  439.  
  440. #include "struct.h"
  441. #include <stdio.h>
  442. #include "node.h"
  443. #include "string.h"
  444.  
  445. /************************** miscellaneous functions *********************/
  446.  
  447. /*
  448.  * NodeExpand
  449.  *
  450.  * Replace object with equivalent object not containing nodes or bottoms.
  451.  *
  452.  * Nodes are converted to equivalent path lists.
  453.  * Bottoms are converted to "?".
  454.  */
  455. void NodeExpand (InOut)
  456.    register ObjectPtr InOut;
  457.    {
  458.       register ListPtr P;
  459.       register NodePtr N;
  460.  
  461.       switch (InOut->Tag) {
  462.  
  463.      case LIST:
  464.         CopyTop (&InOut->List);
  465.         for (P=InOut->List; P!=NULL; P=P->Next) NodeExpand (&P->Val);
  466.         break;
  467.  
  468.      case NODE:
  469.         N = InOut->Node;
  470.         RepTag (InOut,LIST);
  471.         InOut->List = MakePath (N);
  472.         break;
  473.       }
  474.    }
  475.  
  476. /*
  477.  * F_Def
  478.  *
  479.  * Return the object representation of a function definition.
  480.  *
  481.  * Input
  482.  *      *InOut = pathname list
  483.  *
  484.  * Output
  485.  *      *InOut = function definition representation
  486.  */
  487. int F_Def (InOut)               /* imported by Compile in C_comp.c */
  488.    register ObjectPtr InOut;
  489.    {
  490.       extern void ReadDef (), RepBool ();
  491.       register DefPtr D;
  492.  
  493.       if (InOut->Tag != LIST) FunError (ArgNotSeq,InOut);
  494.       else {
  495.      LinkPath (InOut,DEF);
  496.      if (InOut->Tag==NODE && InOut->Node->NodeType==DEF) {
  497.         D = &InOut->Node->NodeData.NodeDef;
  498.         if (D->DefCode.Tag != CODE) {
  499.            if (D->DefCode.Tag == BOTTOM) ReadDef ((NodePtr) NULL,InOut);
  500.            if (D->DefCode.Tag != BOTTOM) {
  501.           RepObject (InOut,&D->DefCode);
  502.           NodeExpand (InOut);
  503.           return;
  504.            }
  505.         }
  506.      }
  507.       }
  508.       RepBool (InOut,0);   /* function not defined */
  509.    }
  510.  
  511. /*
  512.  * F_Apply
  513.  *
  514.  * Apply a function to an object. 
  515.  *
  516.  * Input
  517.  *     InOut = <X F> where F is a function
  518.  *
  519.  * Output
  520.  *     InOut = X : F
  521.  */
  522. private int F_Apply (InOut)
  523.    ObjectPtr InOut;
  524.    {
  525.       register ListPtr P;
  526.  
  527.       /* 
  528.        * We don't want to use PairTest test here, since it would expand
  529.        * the function if its a node.  This would not affect the behavior
  530.        * at all, but would slow things down since the function must be
  531.        * converted to its node representation anyway.
  532.        */
  533.       if (InOut->Tag != LIST || 2 != ListLength (InOut->List))
  534.      FunError ("not a pair",InOut);
  535.       else {
  536.      CopyTop (&InOut->List);
  537.      P = InOut->List;
  538.      if (ApplyCheck (&P->Next->Val)) {
  539.         Apply (&P->Val,&P->Next->Val);
  540.         RepObject (InOut,&P->Val);
  541.      } else 
  542.         FunError ("invalid function",InOut);
  543.       }
  544.    }
  545.  
  546. void D_misc ()
  547.    {      
  548.       (void) PrimDef (F_Apply,"apply",SysNode);
  549.       (void) PrimDef (F_Def,"def",SysNode);
  550.    }
  551.  
  552. /**************************** end of F_misc ****************************/
  553.  
  554. SHAR_EOF
  555. if test -f 'interp/F_pred.c'
  556. then
  557.     echo shar: over-writing existing file "'interp/F_pred.c'"
  558. fi
  559. cat << \SHAR_EOF > 'interp/F_pred.c'
  560.  
  561. /****** F_pred.c ******************************************************/
  562. /**                                                                  **/
  563. /**                    University of Illinois                        **/
  564. /**                                                                  **/
  565. /**                Department of Computer Science                    **/
  566. /**                                                                  **/
  567. /**   Tool: IFP                         Version: 0.5                 **/
  568. /**                                                                  **/
  569. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  570. /**                                                                  **/
  571. /**   Revised by: Arch D. Robison       Date:   Dec 1, 1985          **/
  572. /**                                                                  **/
  573. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  574. /**                            Prof. W. J. Kubitz                    **/
  575. /**                                                                  **/
  576. /**                                                                  **/
  577. /**------------------------------------------------------------------**/
  578. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  579. /**                       All Rights Reserved.                       **/
  580. /**********************************************************************/
  581.  
  582. #include <stdio.h>
  583. #include <math.h>
  584. #include "struct.h"
  585. #include "node.h"
  586.  
  587. /************************** boolean functions **************************/
  588.  
  589. /*
  590.  * PairTest
  591.  *
  592.  * Check if object is a pair of <type1,type2>
  593.  *
  594.  * Input
  595.  *      X = object to test
  596.  *      Mask1,Mask2 = masks representing type1 and type2 respectively.
  597.  *                    E.g 1<<INT is type INT, (1<<INT)|(1<<FLOAT) is numeric.
  598.  *
  599.  * Output
  600.  *      result = 1 if true, 0 if false
  601.  */
  602. boolean PairTest (X,Mask1,Mask2)
  603.    ObjectPtr X;
  604.    int Mask1,Mask2;
  605.    {
  606.       register ListPtr P,Q;
  607.  
  608.       if (X->Tag != LIST) 
  609.      if (X->Tag == NODE) NodeExpand (X);
  610.      else return 0;
  611.  
  612.       if ((P=X->List) == NULL || (Q=P->Next) == NULL || Q->Next!=NULL) return 0;
  613.       if (P->Val.Tag == NODE) NodeExpand (&P->Val);
  614.       if (Q->Val.Tag == NODE) NodeExpand (&Q->Val);
  615.       return Mask1 >> P->Val.Tag & Mask2 >> Q->Val.Tag & 1; 
  616.    }
  617.  
  618. /*
  619.  * Anytime two objects are found to be equal, we can replace one with
  620.  * the other to save memory.  Clearly the memory savings is offset by
  621.  * a little more time, program complexity, and bringing obscure bugs
  622.  * out of the woodwork!  Therefore the replacing action is enabled if
  623.  * MERGE=1, disabled if MERGE=0.
  624.  *
  625.  * P.S. Someone should check if the merging is really worth the cost.
  626.  */
  627. #define MERGE 0
  628.  
  629. /*
  630.  * BoolOp
  631.  *
  632.  * Boolean operation
  633.  *
  634.  * Input
  635.  *      InOut = argument
  636.  *      Op = boolean op (4-bit vector representing truth table)
  637.  *
  638.  * Output
  639.  *      *A = first element of pair if result is true, undefined otherwise
  640.  *      *B = second ...
  641.  */
  642. private BoolOp (InOut,Op)
  643.    ObjectPtr InOut;
  644.    int Op;
  645.    {
  646.       extern void RepBool ();
  647.       register ListPtr P;
  648.  
  649.       if (PairTest (InOut,1<<BOOLEAN,1<<BOOLEAN)) {
  650.      P = InOut->List;
  651.      RepBool (InOut, (Op >> (P->Next->Val.Bool << 1) + P->Val.Bool) & 1);
  652.       } else
  653.      FunError ("not a boolean pair",InOut);
  654.    }
  655.  
  656.  
  657. /*
  658.  * F_Not
  659.  *
  660.  * Boolean negation
  661.  */
  662. private F_Not (InOut)
  663.    ObjectPtr InOut;
  664.    {
  665.       if (InOut->Tag == BOOLEAN) InOut->Bool ^= 1;
  666.       else FunError ("not boolean",InOut);
  667.    }
  668.  
  669.  
  670. /* 
  671.  * F_L2
  672.  */
  673. private F_L2 (InOut)
  674.    ObjectPtr InOut;
  675.    {
  676.       switch (InOut->Tag) {
  677.      case INT: RepBool (InOut,InOut->Int < 2); break;
  678.      case FLOAT: RepBool (InOut,InOut->Float < 2); break;
  679.      default: FunError ("not numeric",InOut); break;
  680.       }
  681.    } 
  682.  
  683. /*
  684.  * F_False
  685.  *
  686.  * Check if argument is boolean false (#f).
  687.  */
  688. private F_False (InOut)
  689.    ObjectPtr InOut;
  690.    {
  691.       if (InOut->Tag == BOTTOM)
  692.      FunError (ArgBottom,InOut);
  693.       else
  694.      if (InOut->Tag == BOOLEAN) InOut->Bool ^= 1;
  695.      else RepBool (InOut,0);
  696.    }
  697.  
  698. /*
  699.  * F_Odd
  700.  *
  701.  * Check if integral argument is odd.
  702.  */
  703. private F_Odd (InOut)
  704.    ObjectPtr InOut;
  705.    {
  706.       FPint N;
  707.  
  708.       switch (GetFPInt (InOut,&N)) {
  709.       case 0:
  710.          RepBool (InOut,(int)N & 1);
  711.          return;
  712.       case 2:
  713.          FunError ("not enough precision",InOut);
  714.          return;
  715.       default:
  716.          FunError ("not an integer",InOut);
  717.          return;
  718.       }
  719.    }
  720.  
  721. /*
  722.  * BoolSeq
  723.  *
  724.  * Evaluate "any" or "all" predicate.
  725.  *
  726.  * Input
  727.  *      *InOut = argument
  728.  *      Op = identity element of operation
  729.  *
  730.  * Output
  731.  *      *InOut = result
  732.  */
  733. private BoolSeq (InOut,Op)
  734.    ObjectPtr InOut;
  735.    int Op;
  736.    {
  737.       register boolean R;
  738.       register ListPtr P;
  739.  
  740.       if (InOut->Tag != LIST) FunError (ArgNotSeq,InOut);
  741.       else {
  742.      R = 0;
  743.      for (P = InOut->List; P != NULL; P=P->Next) 
  744.         if (P->Val.Tag == BOOLEAN) R |= P->Val.Bool ^ Op;
  745.         else {
  746.            FunError ("non-boolean element",InOut);
  747.            return;
  748.         }
  749.      RepBool (InOut, R ^ Op);
  750.       }
  751.    }
  752.  
  753.  
  754. #if MERGE
  755. /*
  756.  * StrMerge
  757.  *
  758.  * Compare two strings.  Merge together if they are equal.
  759.  *
  760.  * Output
  761.  *      result = 1 if equal, 0 otherwise
  762.  */
  763. static int StrMerge (S,T)
  764.    register StrPtr *S,*T;
  765.    {
  766.       if (*S == *T) return 2;               /* strings are identical */
  767.       else if (StrComp (*S,*T)) return 0;   /* strings are different */
  768.       else {
  769.      register StrPtr *U;                /* equal and not identical */
  770.      if ((*S)->SRef < (*T)->SRef) 
  771.         U=S, S=T, T=U;
  772.      if ((*S)->SRef + 1) {              /* S has larger SRef */
  773.         DelSPtr (*T);
  774.         *T = *S;
  775.         (*S)->SRef++;
  776.      }
  777.      return 1;
  778.       }
  779.    }
  780. #endif
  781.  
  782. /*
  783.  * ObEqual
  784.  *
  785.  * Compare two objects.  A comparison tolerance is used for floating point
  786.  * comparisons.
  787.  *
  788.  * Output
  789.  *       result = 0 if objects are not equal
  790.  *                1 if objects are equal within comparison tolerance
  791.  */
  792. boolean ObEqual (X,Y)
  793.    ObjectPtr X,Y;
  794.    {
  795.       if (X->Tag != Y->Tag) {
  796.  
  797.      switch (X->Tag) {
  798.  
  799.         case INT:
  800.            return Y->Tag==FLOAT && 
  801.               !FloatComp ((double) X->Int,(double) Y->Float);
  802.  
  803.         case FLOAT:
  804.            return Y->Tag==INT && 
  805.               !FloatComp ((double) X->Float,(double) Y->Int);
  806.  
  807.         case NODE:
  808.            NodeExpand (X);
  809.            break;
  810.  
  811.         case LIST:
  812.            if (Y->Tag==NODE) NodeExpand (Y); 
  813.            break;
  814.  
  815.         default: return 0;
  816.      }
  817.       }
  818.       switch (X->Tag) {
  819.  
  820.      case BOTTOM:  return 1;
  821.      case BOOLEAN: return X->Bool == Y->Bool;
  822.      case INT:     return X->Int == Y->Int;
  823.      case FLOAT:   return !FloatComp ((double) X->Float, (double) Y->Float);
  824.      case STRING:
  825. #if MERGE
  826.         return StrMerge (&X->String,&Y->String);
  827. #else
  828.         return !StrComp (X->String,Y->String);
  829. #endif
  830.      case LIST: {
  831.         register ListPtr P=X->List, Q=Y->List;
  832.         while (1) {
  833.            if (P == NULL) return Q == NULL;
  834.            if (Q == NULL || !ObEqual (&P->Val,&Q->Val)) return 0;
  835.            P = P->Next; Q = Q->Next;
  836.         }
  837.      }
  838.      case NODE: return X->Node == Y->Node; 
  839.      default:   return 0; /* Tag error */
  840.       }
  841.    }
  842.  
  843. #define max(A,B) ((A) > (B) ? (A) : (B))
  844.  
  845. /*
  846.  * FloatComp
  847.  *
  848.  * X ~= Y if abs(X-Y) / max(abs(X),abs(Y)) <= comparison tolerance.
  849.  *
  850.  * Output
  851.  *      result = -1 if X < Y
  852.  *                0 if X ~= Y
  853.  *                1 if X > Y
  854.  */
  855. int FloatComp (X,Y)
  856.    double X,Y;
  857.    {
  858.       double Xm,Ym,D;
  859.       Xm = fabs (X);
  860.       Ym = fabs (Y);
  861.       D = X-Y;
  862.       if (fabs (D) <= CompTol*max(Xm,Ym)) return 0;
  863.       else return D>0 ? 1 : -1;
  864.    }
  865.  
  866. /*
  867.  * F_Equal
  868.  *
  869.  * Object comparison for equality or inequality
  870.  */
  871. private F_Equal (InOut,Not)
  872.    ObjectPtr InOut;
  873.    int Not;
  874.    {
  875.       if (!PairTest (InOut,~0,~0))
  876.      FunError ("argument not a pair",InOut);
  877.       else 
  878.      RepBool (InOut, Not ^ (0 < ObEqual (&InOut->List->Val,
  879.                          &InOut->List->Next->Val)));
  880.    }
  881.  
  882.  
  883. /*
  884.  * F_Null
  885.  *
  886.  * Null sequence test
  887.  */
  888. private F_Null (InOut)
  889.    ObjectPtr InOut;
  890.    {
  891.       switch (InOut->Tag) {
  892.      case LIST:
  893.         RepBool (InOut, InOut->List == NULL);
  894.         break;
  895.      default: 
  896.         FunError (ArgNotSeq,InOut);
  897.         break;
  898.       }
  899.    }
  900.  
  901.  
  902. /*
  903.  * F_Pair
  904.  *
  905.  * Check if argument is a pair.
  906.  */
  907. private F_Pair (InOut)
  908.    ObjectPtr InOut;
  909.    {
  910.       RepBool (InOut, PairTest (InOut,~0,~0));
  911.    }
  912.  
  913.  
  914. /*
  915.  * F_Tag
  916.  *
  917.  * Check for specified tag
  918.  */
  919. private F_Tag (InOut,TagSet)
  920.    ObjectPtr InOut;
  921.    {
  922.       if (InOut->Tag) 
  923.      RepBool (InOut,TagSet >> InOut->Tag & 1);
  924.       else 
  925.      FunError (ArgBottom,InOut);
  926.    }
  927.  
  928.  
  929. /*
  930.  * CompAtom
  931.  *
  932.  * Compare two atoms for <,<=,=>, or >
  933.  *
  934.  * Strings are ordered lexigraphically.
  935.  * Numbers are ordered in increasing value.
  936.  *
  937.  * Input
  938.  *      *InOut = <X,Y>
  939.  *      Op = comparison bit vector [>,=,<]
  940.  *
  941.  * Output
  942.  *      *InOut = sign (X - Y) or BOTTOM
  943.  */
  944. private CompAtom (InOut,Op)
  945.    ObjectPtr InOut;
  946.    int Op;
  947.    {
  948.       register ObjectPtr X,Y;
  949.       int D,E;
  950.       static char *ErrMessage [3] = {
  951.      "not an atomic pair",
  952.      "booleans not comparable",
  953.      "strings and numbers not comparable"
  954.       };
  955.  
  956.       E = 0;
  957.       if (!PairTest (InOut,ATOMIC,ATOMIC)) E = 1;
  958.       else {
  959.      X = &InOut->List->Val;
  960.      Y = &InOut->List->Next->Val;
  961.      if (X->Tag == BOOLEAN || Y->Tag == BOOLEAN) E = 2;
  962.      else if (X->Tag == STRING || Y->Tag == STRING) {
  963.         if (X->Tag != Y->Tag) E = 3;
  964.         else {
  965.            D = StrComp (X->String,Y->String);
  966.            if (D) D = (D>0) ? 1 : -1;
  967.         }
  968.      } else
  969.         if (X->Tag == INT)
  970.            if (Y->Tag == INT)
  971.           D = (X->Int > Y->Int) - (X->Int < Y->Int);
  972.            else
  973.           D = FloatComp ((double) X->Int,(double) Y->Float);
  974.         else
  975.            if (Y->Tag == INT)
  976.           D = FloatComp ((double) X->Float,(double) Y->Int);
  977.            else
  978.           D = FloatComp ((double) X->Float,(double) Y->Float);
  979.      }
  980.       if (E) FunError (ErrMessage [E-1],InOut);
  981.       else RepBool (InOut, (Op >> (D+1)) & 1);
  982.    }
  983.  
  984.  
  985. /*
  986.  * CompLength
  987.  *
  988.  * Compare the length of two sequences.
  989.  *
  990.  * Input
  991.  *      InOut = argument
  992.  *      Shorter = if 0 then "longer" comparison, "shorter" otherwise.
  993.  */
  994. private CompLength (InOut,Shorter)
  995.    ObjectPtr InOut;
  996.    int Shorter;
  997.    {
  998.       register ListPtr P,Q;
  999.  
  1000.       if (!PairTest (InOut,1<<LIST,1<<LIST))
  1001.      FunError ("not a pair of sequences",InOut);
  1002.       else {
  1003.      P = InOut->List;
  1004.      Q = P->Next->Val.List;
  1005.      P = P->Val.List;
  1006.      while (P != NULL && Q != NULL) {
  1007.         P = P->Next;
  1008.         Q = Q->Next;
  1009.      }
  1010.      RepBool (InOut, (Shorter ? Q : P) != NULL);
  1011.       }
  1012.    }
  1013.  
  1014. /*
  1015.  * F_Member
  1016.  */
  1017. private F_Member (InOut)
  1018.    ObjectPtr InOut;
  1019.    {
  1020.       register ListPtr P;
  1021.       register ObjectPtr X;
  1022.  
  1023.       if (! PairTest (InOut,1 << LIST,~0))
  1024.  
  1025.      FunError (ArgSeqOb,InOut);
  1026.  
  1027.       else {
  1028.  
  1029.      P = InOut->List;
  1030.      X = & P->Next->Val;
  1031.      for (P = P->Val.List; P!=NULL; P=P->Next)
  1032.         if (ObEqual (& P->Val,X)) break;
  1033.      RepBool (InOut, P != NULL);
  1034.       }
  1035.    }
  1036.  
  1037. private OpDef LogicOps [] = {
  1038.    {"all",      1,      BoolSeq},
  1039.    {"and",      0x8,    BoolOp},
  1040.    {"any",      0,      BoolSeq},
  1041.    {"atom",     ATOMIC, F_Tag},
  1042.    {"boolean",  1<<BOOLEAN,     F_Tag},
  1043.    {"false",    -1,     F_False},
  1044.    {"imply",    0xD,    BoolOp},
  1045.    {"longer",   0,      CompLength},
  1046.    {"member",   -1,     F_Member},
  1047.    {"null",     -1,     F_Null},
  1048.    {"numeric",  NUMERIC,F_Tag},
  1049.    {"odd",      -1,     F_Odd},
  1050.    {"or",       0xE,    BoolOp},
  1051.    {"pair",     -1,     F_Pair},
  1052.    {"shorter",  1,      CompLength},
  1053.    {"xor",      0x6,    BoolOp},
  1054.    {"=",        0,      F_Equal},
  1055.    {"~=",       1,      F_Equal},
  1056.    {"~",        -1,     F_Not},
  1057.    {">",        0x4,    CompAtom},
  1058.    {"<",        0x1,    CompAtom},
  1059.    {">=",       0x6,    CompAtom},
  1060.    {"<=",       0x3,    CompAtom},
  1061.    {"l2",    0,    F_L2}
  1062. };
  1063.  
  1064. void D_pred ()
  1065.    {
  1066.       GroupDef (LogicOps, OpCount (LogicOps), LogicNode);
  1067.    }
  1068.  
  1069. /******************************* end of F_pred *******************************/
  1070.  
  1071. SHAR_EOF
  1072. if test -f 'interp/F_seq.c'
  1073. then
  1074.     echo shar: over-writing existing file "'interp/F_seq.c'"
  1075. fi
  1076. cat << \SHAR_EOF > 'interp/F_seq.c'
  1077.  
  1078. /****** F_seq.c *******************************************************/
  1079. /**                                                                  **/
  1080. /**                    University of Illinois                        **/
  1081. /**                                                                  **/
  1082. /**                Department of Computer Science                    **/
  1083. /**                                                                  **/
  1084. /**   Tool: IFP                         Version: 0.5                 **/
  1085. /**                                                                  **/
  1086. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  1087. /**                                                                  **/
  1088. /**   Revised by: Arch D. Robison       Date:   Aug 5, 1986          **/
  1089. /**                                                                  **/
  1090. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  1091. /**                            Prof. W. J. Kubitz                    **/
  1092. /**                                                                  **/
  1093. /**                                                                  **/
  1094. /**------------------------------------------------------------------**/
  1095. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  1096. /**                       All Rights Reserved.                       **/
  1097. /**********************************************************************/
  1098.  
  1099. /******************* sequence (structural) functions ******************/
  1100.  
  1101. #include <stdio.h>
  1102. #include "struct.h"
  1103. #include "node.h"
  1104.  
  1105. /*
  1106.  * F_Cat
  1107.  *
  1108.  * Sequence catenation
  1109.  */
  1110. private F_Cat (InOut)
  1111.    register ObjectPtr InOut;
  1112.    {
  1113.       register MetaPtr E;
  1114.       register ListPtr P;
  1115.  
  1116.       if (InOut->Tag != LIST) {
  1117.      FunError (ArgNotSeq,InOut);
  1118.      return;
  1119.       }
  1120.       P = InOut->List;
  1121.       if (P == NULL) return;
  1122.  
  1123.       do
  1124.      if (P->Val.Tag != LIST) {
  1125.         FunError ("elements not sequences",InOut);
  1126.         return;
  1127.      }
  1128.       while ((P=P->Next)!=NULL);
  1129.  
  1130.       Copy2Top (& InOut->List);
  1131.       if (SysError) return;
  1132.  
  1133.       P = InOut->List;
  1134.       E = &P->Val.List;
  1135.       for (P=P->Next; P!=NULL; P=P->Next) {
  1136.      while (*E!=NULL) E = &(*E)->Next;
  1137.      *E = P->Val.List;
  1138.      P->Val.Tag = BOTTOM;
  1139.       }
  1140.       E = &InOut->List;
  1141.       RepLPtr (E,(*E)->Val.List);
  1142.    }
  1143.  
  1144.  
  1145. /*
  1146.  * F_Iota
  1147.  *
  1148.  * Generate <1...id>
  1149.  */
  1150. private F_Iota (InOut)
  1151.    register ObjectPtr InOut;
  1152.    {
  1153.       FPint N;
  1154.       register FPint K;
  1155.       register ListPtr Pr;
  1156.  
  1157.       switch (GetFPInt (InOut,&N)) {
  1158.      case 1: FunError ("not an integer",InOut); return;
  1159.      case 2: FunError ("too big"       ,InOut); return;
  1160.      case 0:
  1161.         if (N < 0) FunError ("negative",InOut);
  1162.         else {
  1163.            InOut->Tag = LIST;
  1164.            InOut->List = NULL;  
  1165.            NewList (&InOut->List,N);
  1166.            if (SysError) return;
  1167.            for (Pr=InOut->List,K=0; Pr!=NULL; Pr=Pr->Next) 
  1168.           Pr->Val.Tag = INT,
  1169.           Pr->Val.Int = ++K;
  1170.         }
  1171.         return;
  1172.       }
  1173.    }
  1174.  
  1175.  
  1176. /*
  1177.  * F_Id
  1178.  */
  1179. private F_Id ()
  1180.    {
  1181.       return; /* do nothing */;
  1182.    }
  1183.  
  1184.  
  1185. /*
  1186.  * F_Length
  1187.  *
  1188.  * Find sequence length
  1189.  */
  1190. private F_Length (InOut)
  1191.    ObjectPtr InOut;
  1192.    {
  1193.       register FPint N;
  1194.  
  1195.       switch (InOut->Tag) {
  1196.      default:
  1197.         FunError (ArgNotSeq,InOut);
  1198.         return;
  1199.      case LIST:
  1200.         N = ListLength (InOut->List);
  1201.         break;
  1202.       }
  1203.       RepTag (InOut,INT);
  1204.       InOut->Int = N;
  1205.    }
  1206.  
  1207. /*
  1208.  * F_LApnd
  1209.  *
  1210.  *           +--------+
  1211.  * InOut --->|  list  |
  1212.  *           +----+---+ A
  1213.  *                |     |
  1214.  *                V     V
  1215.  *           +------------+      +------------+
  1216.  *           | object | o-+----->|  list  |///|
  1217.  *           +------------+      +---+--------+
  1218.  *                                   |
  1219.  *                                   V
  1220.  *                                  ...
  1221.  */
  1222. private F_LApnd (InOut)
  1223.    ObjectPtr InOut;
  1224.    {
  1225.       MetaPtr A;
  1226.       if (! PairTest (InOut, ~0, SEQUENCE))
  1227.      FunError (ArgObSeq,InOut);
  1228.       else {
  1229.      CopyTop (&InOut->List);
  1230.      A = & InOut->List->Next;
  1231.      RepLPtr (A,(*A)->Val.List);
  1232.       }
  1233.    }
  1234.  
  1235.  
  1236. /*
  1237.  * F_RApnd
  1238.  *
  1239.  *           +--------+
  1240.  * InOut --->|  list  |
  1241.  *           +----+---+
  1242.  *                |
  1243.  *                V
  1244.  *           +------------+      +------------+
  1245.  *           |  list  | o-+----->| object |///|
  1246.  *           +------------+      +------------+
  1247.  *                |
  1248.  *                V
  1249.  *               ...
  1250.  *
  1251.  */
  1252. private F_RApnd (InOut)
  1253.    ObjectPtr InOut;
  1254.    {
  1255.       register MetaPtr E;
  1256.       ListPtr P;
  1257.  
  1258.       if (! PairTest (InOut,1 << LIST,~0))
  1259.      FunError (ArgSeqOb,InOut);
  1260.  
  1261.       else {
  1262.      Copy2Top (& InOut->List);
  1263.      if (SysError) return;
  1264.      P = InOut->List;
  1265.      for (E = &P->Val.List; (*E)!=NULL; E = &(*E)->Next) continue;
  1266.      *E = P->Next;
  1267.      P->Next=NULL;
  1268.      RepLPtr (&InOut->List,P->Val.List);
  1269.      /* No system error possible since source is fresh list */
  1270.       }
  1271.    }
  1272.  
  1273. /*
  1274.  * F_LDist
  1275.  *
  1276.  * Distribute from left
  1277.  */
  1278. private F_LDist (InOut)
  1279.    ObjectPtr InOut;
  1280.    {
  1281.       ListPtr R=NULL;
  1282.       register ListPtr P1,P2,P3,PT;
  1283.       long N;
  1284.  
  1285.       if (!PairTest (InOut, ~0, SEQUENCE))
  1286.  
  1287.      FunError (ArgObSeq,InOut);
  1288.  
  1289.       else {
  1290.  
  1291.      Copy2Top (&InOut->List);
  1292.      if (SysError) return;
  1293.      P1 = InOut->List;             /* P1 = pointer to arg list     */
  1294.      P2 = P1->Next;
  1295.      P3 = P2->Val.List;         /* P3 = pointer to 2nd arg list */
  1296.      P2->Val.List = NULL;
  1297.      N = ListLength (P3); 
  1298.      NewList (&R,N);        /* R = pointer to result list   */
  1299.      if (SysError) return;
  1300.      P2 = Repeat (&P1->Val,N);    /* P2 = pointer to 1st arg list */
  1301.      if (SysError) {DelLPtr (R); return;}
  1302.  
  1303.      for (P1=R; P1!=NULL; P1=P1->Next) {
  1304.         P1->Val.Tag = LIST;
  1305.         P1->Val.List = P2;
  1306.         PT = P2;
  1307.         P2 = P2->Next;
  1308.         PT->Next = P3;
  1309.         PT = P3;
  1310.         P3 = P3->Next;
  1311.         PT->Next = NULL;
  1312.      }
  1313.  
  1314.      DelLPtr (InOut->List);
  1315.      InOut->List = R;
  1316.       }
  1317.    }
  1318.  
  1319.  
  1320. /*
  1321.  * F_RDist
  1322.  *
  1323.  * Distribute from right
  1324.  */
  1325. private F_RDist (InOut)
  1326.    ObjectPtr InOut;
  1327.    {
  1328.       ListPtr R,P,P1,P2;
  1329.       long N;
  1330.  
  1331.       if (! PairTest (InOut, SEQUENCE, ~0))
  1332.  
  1333.      FunError (ArgSeqOb,InOut);
  1334.  
  1335.       else {
  1336.  
  1337.      Copy2Top (&InOut->List);
  1338.      if (SysError) return;
  1339.      P = InOut->List;            /* P = pointer to arg list */
  1340.      P2 = P->Val.List;        /* P2 = pointer to first arg list */
  1341.      P->Val.Tag = BOTTOM;
  1342.      P = P->Next;                     /* P = pointer to 2nd arg */
  1343.      N = ListLength (P2);
  1344.      R = NULL; NewList (&R,N);        /* R = pointer to result list */
  1345.      if (SysError) return;
  1346.  
  1347.      for (P1=R; P1!=NULL; P1=P1->Next) {
  1348.         P1->Val.Tag = LIST;
  1349.         P1->Val.List = CopyLPtr (P);
  1350.         if (SysError) {DelLPtr (R); return;}
  1351.         Rot3 (&P1->Val.List,&P2,&P2->Next);
  1352.      }
  1353.      RepLPtr (&InOut->List,R);
  1354.      DelLPtr (R);
  1355.       }
  1356.    }
  1357.  
  1358.  
  1359. /*
  1360.  * F_Reverse
  1361.  *
  1362.  * Reverse a list
  1363.  */
  1364. F_Reverse (InOut)     /* Imported by F_RInsert in forms.c */
  1365.    ObjectPtr InOut;
  1366.    {
  1367.       ListPtr P,Q;
  1368.  
  1369.       switch (InOut->Tag) {
  1370.      default:
  1371.         FunError (ArgNotSeq,InOut);
  1372.         break;
  1373.      case LIST:
  1374.         P = InOut->List;
  1375.         CopyTop (&P);
  1376.         if (SysError) return;
  1377.         for (Q=NULL; P!=NULL; Rot3 (&P,&P->Next,&Q)) continue; 
  1378.         InOut->List = Q;
  1379.         break;
  1380.       }
  1381.    }
  1382.  
  1383.  
  1384. /*
  1385.  * TransCheck
  1386.  *
  1387.  * Check that InOut is matrix
  1388.  *
  1389.  * Input
  1390.  *     InOut = pointer to object
  1391.  *
  1392.  * Output
  1393.  *     result = NULL iff a matrix, error code otherwise.
  1394.  *     *Cols = number of columns
  1395.  */
  1396. private char *TransCheck (InOut,Cols)
  1397.    ObjectPtr InOut;
  1398.    long *Cols;
  1399.    {
  1400.       register ListPtr V,VR;
  1401.  
  1402.       if (InOut->Tag != LIST)
  1403.      return "argument not a sequence.";
  1404.       else if (NULL == (VR = InOut->List))
  1405.      return "argument is empty sequence.";
  1406.       else
  1407.      for (V = VR; V !=NULL; V = V->Next)
  1408.         if (V->Val.Tag != LIST)
  1409.            return "argument subelements must be sequences.";
  1410.         else if (V==VR) *Cols = ListLength (V->Val.List);
  1411.         else if (*Cols != ListLength (V->Val.List))
  1412.            return "argument not rectangular.";
  1413.         else continue;
  1414.       return NULL;
  1415.    }
  1416.  
  1417.  
  1418. /*
  1419.  * F_Trans
  1420.  *
  1421.  * Transpose a matrix (sequence of sequences)
  1422.  */
  1423. private F_Trans (InOut)
  1424.    ObjectPtr InOut;
  1425.    {
  1426.       char *E; long Cols;
  1427.       ListPtr VR,HR,H;
  1428.       register ListPtr U,V;
  1429.       register MetaPtr A;
  1430.  
  1431.       /* Check for rectangularness */
  1432.       if (NULL != (E = TransCheck (InOut,&Cols))) {
  1433.      FunError (E,InOut);
  1434.      return;
  1435.       }
  1436.  
  1437.       /* Make fresh copy of vertical top level  and rows */
  1438.       Copy2Top (&InOut->List);
  1439.       if (SysError) return;
  1440.       else VR = InOut->List;
  1441.     
  1442.       /* Make horizontal top level */
  1443.       HR = NULL;
  1444.       NewList (&HR,Cols);
  1445.  
  1446.       /* Transpose matrix column by column */
  1447.       for (H=HR; H!=NULL; H=H->Next) {
  1448.      H->Val.Tag = LIST;
  1449.      H->Val.List = VR->Val.List;
  1450.  
  1451.      /* Relink the column and advance the VR list to the next column */
  1452.      for (V=VR; V!=NULL; V=U) {
  1453.         U = V->Next;
  1454.         A = &V->Val.List->Next;
  1455.         V->Val.List = *A;
  1456.         *A = U==NULL ? NULL : U->Val.List;
  1457.      }
  1458.       }
  1459.       /* Delete the old vertical top level and return new matrix */
  1460.       DelLPtr (VR); InOut->List = HR;
  1461.    }
  1462.  
  1463.  
  1464. /*
  1465.  * F_Tail
  1466.  */
  1467. private F_Tail (InOut)
  1468.    ObjectPtr InOut;
  1469.    {
  1470.       register ListPtr P;
  1471.       switch (InOut->Tag) {
  1472.      default:
  1473.         FunError (ArgNotSeq,InOut);
  1474.         break;
  1475.      case LIST:
  1476.         if (NULL == (P = InOut->List)) FunError (ArgNull,InOut);
  1477.         else RepLPtr (&InOut->List,P->Next);
  1478.         break;
  1479.       }
  1480.    }
  1481.  
  1482.  
  1483. /*
  1484.  * F_RTail
  1485.  *
  1486.  * Drop last element
  1487.  */
  1488. private F_RTail (InOut)
  1489.    ObjectPtr InOut;
  1490.    {
  1491.       register MetaPtr A;
  1492.       if (InOut->Tag != LIST)
  1493.      FunError (ArgNotSeq,InOut);
  1494.       else if (NULL == InOut->List)
  1495.      FunError (ArgNull,InOut);
  1496.       else {
  1497.      CopyTop (A = &InOut->List);
  1498.      if (SysError) return;
  1499.      while ((*A)->Next != NULL) A = &(*A)->Next;
  1500.      RepLPtr (A,(ListPtr) NULL);
  1501.       }
  1502.    }
  1503.  
  1504.  
  1505. OpDef SeqOps [] = {
  1506.    {"apndl",    -1,     F_LApnd},
  1507.    {"apndr",    -1,     F_RApnd},
  1508.    {"cat",      -1,     F_Cat},
  1509.    {"distl",    -1,     F_LDist},
  1510.    {"distr",    -1,     F_RDist},
  1511.    {"id",       -1,     F_Id},
  1512.    {"iota",     -1,     F_Iota},
  1513.    {"length",   -1,     F_Length},
  1514.    {"reverse",  -1,     F_Reverse},
  1515.    {"tl",       -1,     F_Tail},
  1516.    {"tlr",      -1,     F_RTail},
  1517.    {"trans",    -1,     F_Trans}
  1518. };
  1519.  
  1520. void D_seq ()
  1521.    {
  1522.       GroupDef (SeqOps, OpCount (SeqOps), SysNode);
  1523.    }  
  1524.  
  1525. /************************** end of F_seq **************************/
  1526.  
  1527. SHAR_EOF
  1528. if test -f 'interp/F_ss.c'
  1529. then
  1530.     echo shar: over-writing existing file "'interp/F_ss.c'"
  1531. fi
  1532. cat << \SHAR_EOF > 'interp/F_ss.c'
  1533.  
  1534. /****** F_ss.c ********************************************************/
  1535. /**                                                                  **/
  1536. /**                    University of Illinois                        **/
  1537. /**                                                                  **/
  1538. /**                Department of Computer Science                    **/
  1539. /**                                                                  **/
  1540. /**   Tool: IFP                         Version: 0.5                 **/
  1541. /**                                                                  **/
  1542. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  1543. /**                                                                  **/
  1544. /**   Revised by: Arch D. Robison       Date:  July 4, 1985          **/
  1545. /**                                                                  **/
  1546. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  1547. /**                            Prof. W. J. Kubitz                    **/
  1548. /**                                                                  **/
  1549. /**                                                                  **/
  1550. /**------------------------------------------------------------------**/
  1551. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  1552. /**                       All Rights Reserved.                       **/
  1553. /**********************************************************************/
  1554.  
  1555. #include <stdio.h>
  1556. #include "struct.h"
  1557. #include "node.h"
  1558.  
  1559. /*************************** Searching and Sorting ***************************/
  1560.  
  1561. /*
  1562.  * F_Assoc
  1563.  *
  1564.  * Just like LISP assoc, except that #f is returned if the key is not found.
  1565.  *
  1566.  * [association-list,key] | assoc == element of association list or #f
  1567.  */
  1568. private F_Assoc (InOut)
  1569.    ObjectPtr InOut;
  1570.    {
  1571.       register ListPtr P;
  1572.       register ObjectPtr Key;
  1573.  
  1574.       if (!PairTest (InOut,1<<LIST,~0))
  1575.       FunError (ArgSeqOb,InOut);
  1576.  
  1577.       else {
  1578.  
  1579.      P = InOut->List;
  1580.      Key = &P->Next->Val;
  1581.  
  1582.      for (P = P->Val.List; P != NULL; P=P->Next)
  1583.         if (P->Val.Tag != LIST) {
  1584.            FunError ("element not sequence",InOut);
  1585.            return;
  1586.         } else
  1587.            if (ObEqual (&P->Val.List->Val,Key)) {
  1588.           RepObject (InOut,&P->Val);
  1589.           return;
  1590.            }
  1591.  
  1592.      RepBool (InOut,0);     /* key not found, return #f */
  1593.       }
  1594.    }
  1595.  
  1596.  
  1597. void D_ss ()
  1598.    {
  1599.       (void) PrimDef (F_Assoc,"assoc",SysNode);
  1600.    }
  1601.  
  1602. /******************************* end of F_ss.c *******************************/
  1603.  
  1604. SHAR_EOF
  1605. if test -f 'interp/F_string.c'
  1606. then
  1607.     echo shar: over-writing existing file "'interp/F_string.c'"
  1608. fi
  1609. cat << \SHAR_EOF > 'interp/F_string.c'
  1610.  
  1611. /****** F_string.c ****************************************************/
  1612. /**                                                                  **/
  1613. /**                    University of Illinois                        **/
  1614. /**                                                                  **/
  1615. /**                Department of Computer Science                    **/
  1616. /**                                                                  **/
  1617. /**   Tool: IFP                         Version: 0.5                 **/
  1618. /**                                                                  **/
  1619. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  1620. /**                                                                  **/
  1621. /**   Revised by: Arch D. Robison       Date:  July 5, 1985          **/
  1622. /**                                                                  **/
  1623. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  1624. /**                            Prof. W. J. Kubitz                    **/
  1625. /**                                                                  **/
  1626. /**                                                                  **/
  1627. /**------------------------------------------------------------------**/
  1628. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  1629. /**                       All Rights Reserved.                       **/
  1630. /**********************************************************************/
  1631.  
  1632. #include <stdio.h>
  1633. #include "struct.h"
  1634. #include "string.h"
  1635. #include "node.h"
  1636.  
  1637. /*
  1638.  * F_Patom
  1639.  *
  1640.  * Convert an atom to it's string representation.
  1641.  */
  1642. private F_Patom (InOut)
  1643.    register ObjectPtr InOut;
  1644.    {
  1645.       CharPtr U;
  1646.       char Buf[255];
  1647.       StrPtr S;
  1648.       register char *T;
  1649.       extern char *sprintf();
  1650.  
  1651.       T = Buf;
  1652.       switch (InOut->Tag) {
  1653.      case INT:
  1654.         (void) sprintf (T,"%d",InOut->Int);
  1655.         break;
  1656.      case FLOAT:
  1657.         (void) sprintf (T,"%g",InOut->Float);
  1658.         break;
  1659.      case BOOLEAN:
  1660.         (void) sprintf (T,InOut->Bool ? "t":"f");
  1661.         break;
  1662.      case STRING:
  1663.         return;
  1664.      default:
  1665.         FunError ("not atomic",InOut);
  1666.         return;
  1667.       }
  1668.       S = NULL;
  1669.       CPInit (&U,&S);
  1670.       do CPAppend (&U,*T); while (*T++);
  1671.       RepTag (InOut,STRING);
  1672.       InOut->String = S;
  1673.    }
  1674.  
  1675.  
  1676. /*
  1677.  * F_Explode
  1678.  *
  1679.  * Convert a string to a list of characters
  1680.  */
  1681. private F_Explode (InOut)
  1682.    ObjectPtr InOut;
  1683.    {
  1684.       ListPtr Result = NULL;
  1685.       MetaPtr A = &Result;
  1686.       CharPtr U;
  1687.       char C[2];
  1688.  
  1689.       if (InOut->Tag != STRING)
  1690.      FunError ("not a string",InOut);
  1691.       else {
  1692.      CPInit (&U,&InOut->String);
  1693.      while (CPRead (&U,C,2)) {
  1694.         NewList (A,1L);
  1695.         if (SysError) {DelLPtr (Result); return;}
  1696.         (*A)->Val.Tag = STRING;
  1697.         (*A)->Val.String = CopySPtr (CharString [C[0] & 0x7F]);
  1698.         A = &(*A)->Next;
  1699.      }
  1700.      RepTag (InOut,LIST);
  1701.      InOut->List = Result;
  1702.       }
  1703.    }
  1704.  
  1705.  
  1706. /*
  1707.  * F_Implode
  1708.  *
  1709.  * Catenate a list of strings into a single string.
  1710.  */
  1711. private F_Implode (InOut)
  1712.    ObjectPtr InOut;
  1713.    {
  1714.       CharPtr U,V;
  1715.       char C[2];
  1716.       ListPtr P;
  1717.       StrPtr S;
  1718.  
  1719.       if (InOut->Tag != LIST)
  1720.      FunError ("not a sequence",InOut);
  1721.       else {
  1722.      S = NULL;
  1723.      CPInit (&U,&S);
  1724.      for (P = InOut->List; P != NULL; P=P->Next) {
  1725.         if (P->Val.Tag != STRING) {
  1726.            FunError ("non-string in sequence",InOut);
  1727.            CPAppend (&U,'\0');
  1728.            DelSPtr (S);
  1729.            return;
  1730.         } else {
  1731.            CPInit (&V,&P->Val.String);
  1732.            while (CPRead (&V,C,2)) CPAppend (&U,C[0]);
  1733.         }
  1734.      }
  1735.      CPAppend (&U,'\0');
  1736.      RepTag (InOut,STRING);
  1737.      InOut->String = S;
  1738.       }
  1739.    }
  1740.  
  1741.  
  1742. void D_string ()
  1743.    {                             
  1744.       (void) PrimDef (F_Explode,"explode",SysNode);
  1745.       (void) PrimDef (F_Implode,"implode",SysNode);
  1746.       (void) PrimDef (F_Patom,"patom",SysNode);
  1747.    }
  1748.  
  1749. /************************** end of F_string **************************/
  1750.  
  1751. SHAR_EOF
  1752. if test -f 'interp/F_subseq.c'
  1753. then
  1754.     echo shar: over-writing existing file "'interp/F_subseq.c'"
  1755. fi
  1756. cat << \SHAR_EOF > 'interp/F_subseq.c'
  1757.  
  1758. /****** F_subseq.c ****************************************************/
  1759. /**                                                                  **/
  1760. /**                    University of Illinois                        **/
  1761. /**                                                                  **/
  1762. /**                Department of Computer Science                    **/
  1763. /**                                                                  **/
  1764. /**   Tool: IFP                         Version: 0.5                 **/
  1765. /**                                                                  **/
  1766. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  1767. /**                                                                  **/
  1768. /**   Revised by: Arch D. Robison       Date:  Apr 28, 1986          **/
  1769. /**                                                                  **/
  1770. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  1771. /**                            Prof. W. J. Kubitz                    **/
  1772. /**                                                                  **/
  1773. /**                                                                  **/
  1774. /**------------------------------------------------------------------**/
  1775. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  1776. /**                       All Rights Reserved.                       **/
  1777. /**********************************************************************/
  1778.  
  1779. #include <stdio.h>    /* defines NULL */
  1780. #include "struct.h"
  1781. #include "node.h"
  1782.  
  1783. /*
  1784.  * ListIndex
  1785.  *
  1786.  * Check an argument to make sure it is of the form <sequence integer>
  1787.  *
  1788.  * Input
  1789.  *      InOut = argument
  1790.  *
  1791.  * Output
  1792.  *      *L = sequence or array if no error
  1793.  *      result = -1 if error occurred, index otherwise
  1794.  */
  1795. private long ListIndex (InOut,L)
  1796.    ObjectPtr InOut;
  1797.    ListPtr *L;
  1798.    {
  1799.       register ListPtr P;
  1800.       FPint N;
  1801.  
  1802.       if (!PairTest (InOut, SEQUENCE, NUMERIC)) {
  1803.      FunError ("not <sequence number>",InOut);
  1804.      return -1;
  1805.       } else {
  1806.      P = InOut->List;
  1807.      *L = P->Val.List;
  1808.      P = P->Next;
  1809.      switch (GetFPInt (&P->Val,&N)) {
  1810.         default: /* actually case 0, but we need to keep lint happy */
  1811.            if (N >= 0) return N;
  1812.            else {
  1813.           FunError ("negative index",InOut);
  1814.           return -1;
  1815.            }
  1816.         case 1: 
  1817.            FunError ("index not integral",InOut); 
  1818.            return -1;
  1819.         case 2:
  1820.            FunError ("index too big",InOut);
  1821.            return -1;
  1822.      }
  1823.       }
  1824.    }
  1825.  
  1826. #define SCATTER_STORE 0
  1827.  
  1828. #if SCATTER_STORE
  1829. /*
  1830.  * F_Scatter
  1831.  *
  1832.  * Scatter store function
  1833.  *
  1834.  * Input
  1835.  *      <<D1 D2 ... Dn> <<V1 I1> <V2 I2> ... <Vm Im>>>
  1836.  *
  1837.  * Output
  1838.  *      <E1 E2 ... En>
  1839.  *
  1840.  * Ek = Dk if there is no Ij == k
  1841.  *      Vj if Ij == k
  1842.  *
  1843.  * Result is BOTTOM if Ij==Ik for j!=k or Ij < 1 or Ij > n
  1844.  *
  1845.  * Perversions: uses LRef field for markers
  1846.  */
  1847. private F_Scatter (InOut)
  1848.    ObjectPtr InOut;
  1849.    {
  1850.       register ListPtr P1,P2,Q,R;
  1851.       register long N;
  1852.       FPint M;
  1853.  
  1854.       if (!PairTest (InOut,1<<LIST,1<<LIST))
  1855.      FunError ("not <sequence sequence>",InOut);
  1856.  
  1857.       else {
  1858.  
  1859.      Copy2Top (&InOut->List); /* only need fresh first element */
  1860.      P1 = InOut->List;
  1861.      R = P1->Val.List;
  1862.      N = ListLength (R);
  1863.  
  1864.      for (P1 = P1->Next->Val.List; P1!=NULL; P1=P1->Next) {
  1865.         if (!PairTest (&P1->Val,~0,NUMERIC)) {
  1866.            FunError ("invalid store pair",InOut);
  1867.            return;
  1868.         }
  1869.         P2 = P1->Val.List;
  1870.         if (GetFPInt (&P2->Next->Val,&M) || M < 1 || M > N) {
  1871.            FunError ("invalid index",InOut);
  1872.            return;
  1873.         }
  1874.         for (Q=R; --M; Q=Q->Next) continue;
  1875.         if (++Q->LRef > 2) {
  1876.            for (Q=R; Q!=NULL; Q=Q->Next) Q->LRef = 1;
  1877.            FunError ("duplicate index",InOut);
  1878.            return;
  1879.         }
  1880.         RepObject (&Q->Val,&P2->Val);
  1881.      }
  1882.      for (Q=R; Q!=NULL; Q=Q->Next) Q->LRef = 1;
  1883.      RepObject (InOut,&InOut->List->Val);
  1884.       }
  1885.    }
  1886. #endif
  1887.  
  1888. /*
  1889.  * F_Pick
  1890.  * 
  1891.  * Pick the nth element of a sequence
  1892.  *
  1893.  * Input
  1894.  *      InOut = pointer to <sequence number>
  1895.  */
  1896. private F_Pick (InOut)
  1897.    ObjectPtr InOut;
  1898.    {
  1899.       register FPint N;
  1900.       ListPtr P; 
  1901.  
  1902.       if ((N = ListIndex (InOut,&P)) >= 0) {
  1903.      if (N <= 0) {
  1904.         FunError ("non-positive index",InOut);
  1905.      } else if (P == NULL) FunError ("empty sequence",InOut);
  1906.      else {
  1907.         while (--N > 0)
  1908.            if ((P = P->Next) == NULL) {
  1909.           FunError ("index out of bounds",InOut);
  1910.           return;
  1911.            }
  1912.         RepObject (InOut,&P->Val);
  1913.      }
  1914.       }
  1915.    }
  1916.  
  1917.  
  1918. /*
  1919.  * F_Repeat
  1920.  *
  1921.  * Create a repetition of an item.
  1922.  *
  1923.  * E.g. <x 8> == <x x x x x x x x>
  1924.  */
  1925. private F_Repeat (InOut)
  1926.    register ObjectPtr InOut;
  1927.    {
  1928.       FPint N;
  1929.       register ListPtr P;
  1930.  
  1931.       if (!PairTest (InOut,~0,NUMERIC))
  1932.      FunError ("not <object number>",InOut);
  1933.  
  1934.       else {
  1935.      P = InOut->List;
  1936.      switch (GetFPInt (&P->Next->Val,&N)) {
  1937.         case 1:
  1938.            FunError ("repetition value not integer",InOut);
  1939.            break;
  1940.         case 2:
  1941.            FunError ("repetition value too big",InOut);
  1942.            break;
  1943.         case 0:
  1944.            if (N < 0) FunError ("negative repetition",InOut);
  1945.            else {
  1946.           P = Repeat (&P->Val,(long) N);
  1947.           DelLPtr (InOut->List);
  1948.           InOut->List = P;
  1949.            }
  1950.            break;
  1951.         }
  1952.       }
  1953.    }
  1954.  
  1955.  
  1956. /*
  1957.  * F_RDrop
  1958.  *
  1959.  * Drop the last n elements from a sequence
  1960.  *
  1961.  * Input
  1962.  *      InOut = pointer to <sequence number>
  1963.  */
  1964. private F_RDrop (InOut)
  1965.    ObjectPtr InOut;
  1966.    {
  1967.       register FPint N;
  1968.       ListPtr P,Result;
  1969.       register ListPtr R;
  1970.  
  1971.       if ((N = ListIndex (InOut,&P)) >= 0) 
  1972.      if ((N = ListLength (P) - N) < 0) 
  1973.         FunError ("sequence too short",InOut);
  1974.      else {
  1975.         Result = NULL;
  1976.         NewList (&Result,N);
  1977.         for (R = Result; R!=NULL; P=P->Next,R=R->Next) 
  1978.            CopyObject (&R->Val,&P->Val);
  1979.         DelLPtr (InOut->List);
  1980.         InOut->List = Result;
  1981.      }
  1982.    }
  1983.  
  1984.  
  1985. /*
  1986.  * F_LDrop
  1987.  *
  1988.  * Drop the first n elements from a sequence
  1989.  *
  1990.  * Input
  1991.  *      InOut = pointer to <sequence number>
  1992.  */
  1993. private F_LDrop (InOut)
  1994.    ObjectPtr InOut;
  1995.    {
  1996.       register FPint N;   
  1997.       ListPtr P; 
  1998.  
  1999.       if ((N = ListIndex (InOut,&P)) >= 0) {
  2000.      for (; --N >= 0; P = P->Next)
  2001.         if (P == NULL) {
  2002.            FunError ("sequence too short",InOut);
  2003.            return;
  2004.         }
  2005.      RepLPtr (&InOut->List,P);
  2006.       }
  2007.    }
  2008.  
  2009.  
  2010. /*
  2011.  * F_LTake
  2012.  *
  2013.  * Take the first n elements from a sequence
  2014.  *
  2015.  * Input
  2016.  *      InOut = pointer to <sequence number>
  2017.  */
  2018. private F_LTake (InOut)
  2019.    ObjectPtr InOut;
  2020.    {
  2021.       register long N;
  2022.       ListPtr P,Result;
  2023.       register ListPtr R;
  2024.  
  2025.       if ((N = ListIndex (InOut,&P)) >= 0) {
  2026.      Result = NULL;
  2027.      NewList (&Result,N);
  2028.      for (R = Result; R!=NULL; P=P->Next, R=R->Next)
  2029.         if (P != NULL)
  2030.            CopyObject (&R->Val,&P->Val);
  2031.         else {
  2032.            FunError ("sequence too short",InOut);
  2033.            DelLPtr (Result);
  2034.            return;
  2035.         } 
  2036.      DelLPtr (InOut->List);
  2037.      InOut->List = Result;
  2038.       }
  2039.    }
  2040.  
  2041.  
  2042. /*
  2043.  * F_RTake
  2044.  *
  2045.  * Take the last n elements from a sequence
  2046.  *
  2047.  * Input
  2048.  *      InOut = pointer to <sequence number>
  2049.  */
  2050. private F_RTake (InOut)
  2051.    ObjectPtr InOut;
  2052.    {
  2053.       register FPint N;
  2054.       ListPtr P;
  2055.  
  2056.       if ((N = ListIndex (InOut,&P)) >= 0) 
  2057.      if ((N = ListLength (P) - N) < 0)
  2058.         FunError ("sequence too short",InOut);
  2059.      else {
  2060.         while (--N >=0) P = P->Next;
  2061.         RepLPtr (&InOut->List,P);
  2062.      }
  2063.    }
  2064.  
  2065. private OpDef SubSeqOps [] = {
  2066.    {"dropl",    -1,     F_LDrop},
  2067.    {"dropr",    -1,     F_RDrop},
  2068.    {"pick",     -1,     F_Pick},
  2069.    {"repeat",   -1,     F_Repeat},
  2070.    {"takel",    -1,     F_LTake},
  2071.    {"taker",    -1,     F_RTake}
  2072. #if SCATTER_STORE
  2073.    {"scatter",  -1,     F_Scatter},
  2074. #endif
  2075. };
  2076.  
  2077. void D_subseq ()
  2078.    {
  2079.       GroupDef (SubSeqOps, OpCount (SubSeqOps), SysNode);
  2080.    }
  2081.  
  2082. /************************** end of F_subseq **************************/
  2083.  
  2084. SHAR_EOF
  2085. #    End of shell archive
  2086. exit 0
  2087.  
  2088. -- 
  2089.  
  2090. Rich $alz            "Anger is an energy"
  2091. Cronus Project, BBN Labs    rsalz@pineapple.bbn.com
  2092. Moderator, comp.sources.unix    sources@uunet.uu.net
  2093.